Deutsche Edition 1/Deutsche Edition 1.iso/amok/amok_lha/amok46.lha/Module/IntuitionTools.mod

Text File | 1993-08-15 | 18KB | 746 lines

(*
 * -------------------------------------------------------------------------
 *
 *    :Program.    IntuitionTools.mod
 *    :Contents.    Proceduren zum Initialisieren von Amiga-Strukturen,
 *    :Contents.    atomare Gadgetaktionen.
 *    :Author.    Reiner Nix
 *    :Address.    Geranienhof 2, 5000 Köln 71 Seeberg
 *    :Copyright.    Public Domain
 *    :Language.    Modula-2
 *    :Translator.    M2Amiga A-L V3.3d
 *    :History.    V1.0a    26.9.'90
 *
 * -------------------------------------------------------------------------
 *)

IMPLEMENTATION MODULE IntuitionTools;

FROM    SYSTEM        IMPORT    ADR, ADDRESS, BITSET, LONGSET;
FROM    Arts        IMPORT    Assert, TermProcedure;
FROM    Exec        IMPORT    UByte, IOStdReq,
                DevicePtr,
                OpenDevice, CloseDevice;
FROM    Dos        IMPORT    Delay;
FROM    KeyMap        IMPORT    KeyMapPtr;
FROM    Console        IMPORT    consoleName,
                RawKeyConvert;
FROM    InputEvent    IMPORT    InputEvent, Class, QualifierSet;
FROM    Graphics    IMPORT    DrawModeSet, FontStyleSet, FontFlagSet,
                ViewModes,ViewModeSet,
                TextAttrPtr, BitMapPtr,
                TextAttr, BitMap,
                InitBitMap;
FROM    Intuition    IMPORT    maxBody, menuEnabled,
                ScreenFlagSet, WindowFlagSet, IDCMPFlagSet,
                ActivationFlagSet, PropInfoFlagSet,
                MenuItemFlags, MenuItemFlagSet,
                GadgetFlagSet, gadgDisabled, selected,
                GadgetPtr, ImagePtr, ScreenPtr, BorderPtr,
                IntuiTextPtr, MenuPtr, MenuItemPtr,
                WindowPtr, IntuitionBasePtr,
                NewScreen, NewWindow, Border, IntuiText,
                Menu, MenuItem, Gadget, PropInfo, StringInfo,
                IntuiMessage,
                RefreshGList, RemoveGadget, AddGadget,
                RemoveGList;
FROM    Heap        IMPORT    Allocate, AllocMem, Deallocate;


CONST    IntuitionWait    = 1;
    Tieftaucher    ="Depth <= 0 ?";
    keinSpeicher    ="nicht genug Speicher frei!";
    widthFehler    ="Breite muß Vielfaches von 16 sein!";
    ConsoleFehler    ="kann Console Device nicht öffnen!";


VAR    ConsoleDevice    :DevicePtr;
    ConsoleRequest    :IOStdReq;


PROCEDURE initNewScreen    (VAR newScreen            :NewScreen;
                 X,Y, Width,Height,
                             Depth            :INTEGER;
                         DetailPen, BlockPen    :UByte;
                          Mode            :GraphMode;
                         Type            :ScreenFlagSet;
                          Font            :TextAttrPtr;
                          DefaultTitle        :ADDRESS);

BEGIN
WITH newScreen DO
  leftEdge    := X;
  topEdge    := Y;
  width        := Width;
  height    := Height;
  depth        := Depth;
  detailPen    := DetailPen;
  blockPen    := BlockPen;
  CASE Mode OF
    LoRes    :viewModes := ViewModeSet {}
  | LoResLace    :viewModes := ViewModeSet {lace}
  | HiRes    :viewModes := ViewModeSet {hires}
  | HiResLace    :viewModes := ViewModeSet {hires,lace}
  | LoResHAM    :viewModes := ViewModeSet {ham}
  | LoResEx    :viewModes := ViewModeSet {extraHalfbrite}
    END;
  type        := Type;
  font        := Font;
  defaultTitle    := DefaultTitle;
  gadgets    := NIL;
  customBitMap    := NIL
  END
END initNewScreen;


PROCEDURE initNewWindow    (VAR newWindow            :NewWindow;
                 X,Y, Width,Height        :INTEGER;
                             DetailPen, BlockPen    :UByte;
                             IDCMPFlags            :IDCMPFlagSet;
                             Flags            :WindowFlagSet;
                             FirstGadget        :GadgetPtr;
                             CheckMark            :ImagePtr;
                             Title            :ADDRESS;
                             Screen            :ScreenPtr;
                             BitMap            :BitMapPtr;
                             MinWidth,MinHeight,
                             MaxWidth,MaxHeight        :INTEGER;
                             Type            :ScreenFlagSet);

BEGIN
WITH newWindow DO
  leftEdge    := X;
  topEdge    := Y;
  width        := Width;
  height    := Height;
  detailPen    := DetailPen;
  blockPen    := BlockPen;
  idcmpFlags    := IDCMPFlags;
  flags        := Flags;
  firstGadget    := FirstGadget;
  checkMark    := CheckMark;
  title        := Title;
  screen    := Screen;
  bitMap    := BitMap;
  minWidth    := MinWidth;
  minHeight    := MinHeight;
  maxWidth    := MaxWidth;
  maxHeight    := MaxHeight;
  type        := Type
  END
END initNewWindow;


PROCEDURE openBitMap        (    Width, Height,
                     Depth        :INTEGER) :BitMapPtr;

VAR    Fehler        :BOOLEAN;
    bitMap        :BitMapPtr;
    i        :CARDINAL;
    RasterSize    :LONGINT;

BEGIN
Assert (Depth >= 0, ADR (Tieftaucher));
Assert (Width MOD 16 = 0, ADR (widthFehler));
Allocate (bitMap, SIZE (BitMap));
Assert (bitMap # NIL, ADR (keinSpeicher));
InitBitMap (bitMap^, Depth, Width, Height);
WITH bitMap^ DO
  RasterSize := LONGINT (bytesPerRow) * LONGINT (rows);
  Fehler := FALSE;
  FOR i := 0 TO Depth-1 DO
    AllocMem (planes[i], RasterSize, TRUE);
    Fehler := (planes[i] = NIL) OR Fehler
    END;
  IF Fehler THEN
    FOR i := 0 TO Depth-1 DO
      IF planes[i] # NIL THEN
        Deallocate (planes[i])
        END
      END;
    Deallocate (bitMap);
    bitMap := NIL
    END
  END;
RETURN bitMap
END openBitMap;


PROCEDURE initBorder    (VAR border            :Border;
                 X,Y            :INTEGER;
                             Front,Back            :UByte;
                             Drawmodes            :DrawModeSet;
                             Count            :UByte;
                             XY                :ADDRESS;
                             NextBorder            :BorderPtr);

BEGIN
WITH border DO
  leftEdge    := X;
  topEdge    := Y;
  frontPen    := Front;
  backPen    := Back;
  drawMode    := Drawmodes;
  count        := Count;
  xy        := XY;
  nextBorder    := NextBorder
  END
END initBorder;


PROCEDURE makeBorder    (VAR borderXY            :ARRAY OF INTEGER;
                 Width,Height        :INTEGER);

BEGIN
IF HIGH (borderXY) < 9 THEN
  RETURN
  END;
borderXY[0] := 0;        borderXY[1] := 0;
borderXY[2] := Width-1;        borderXY[3] := 0;
borderXY[4] := Width-1;        borderXY[5] := Height-1;
borderXY[6] := 0;        borderXY[7] := Height-1;
borderXY[8] := 0;        borderXY[9] := 0
END makeBorder;


PROCEDURE initIntuiText (VAR text            :IntuiText;
                 Front,Back            :UByte;
                             Drawmodes            :DrawModeSet;
                             X,Y            :INTEGER;
                             Font            :TextAttrPtr;
                             IText            :ADDRESS;
                             NextText            :IntuiTextPtr);

BEGIN
WITH text DO
  frontPen    := Front;
  backPen    := Back;
  drawMode    := Drawmodes;
  leftEdge    := X;
  topEdge    := Y;
  iTextFont    := Font;
  iText        := IText;
  nextText    := NextText
  END
END initIntuiText;


PROCEDURE initTextAttr    (VAR textAttr            :TextAttr;
                 Name            :ADDRESS;
                             YSize            :CARDINAL;
                             Style            :FontStyleSet;
                             Flags            :FontFlagSet);

BEGIN
WITH textAttr DO
  name        := Name;
  ySize        := YSize;
  style        := Style;
  flags        := Flags
  END
END initTextAttr;


PROCEDURE initMenu    (VAR menu            :Menu;
                 NextMenu            :MenuPtr;
                             X,Y, Width,Height        :INTEGER;
                             Flags            :BITSET;
                             Name            :ADDRESS;
                             FirstItem            :MenuItemPtr);

BEGIN
WITH menu DO
  nextMenu    := NextMenu;
  leftEdge    := X;
  topEdge    := Y;
  width        := Width;
  height    := Height;
  flags        := Flags;
  menuName    := Name;
  firstItem    := FirstItem
  END
END initMenu;


PROCEDURE initMenuItem    (VAR menuItem            :MenuItem;
                 NextItem            :MenuItemPtr;
                             X,Y, Width,Height        :INTEGER;
                             Flags            :MenuItemFlagSet;
                             MutualExclude        :LONGSET;
                             ItemFill,
                             SelectFill            :ADDRESS;
                             Command            :CHAR;
                             SubItem            :MenuItemPtr;
                             NextSelect            :CARDINAL);

BEGIN
WITH menuItem DO
  nextItem    := NextItem;
  leftEdge    := X;
  topEdge    := Y;
  width        := Width;
  height    := Height;
  flags        := Flags;
  mutualExclude    := MutualExclude;
  itemFill    := ItemFill;
  selectFill    := SelectFill;
  command    := Command;
  subItem    := SubItem;
  nextSelect    := NextSelect
  END
END initMenuItem;


PROCEDURE initGadget    (VAR gadget            :Gadget;
                 NextGadget            :GadgetPtr;
                             X,Y, Width,Height        :INTEGER;
                             Flags            :GadgetFlagSet;
                             Activation            :ActivationFlagSet;
                             GadgetType            :CARDINAL;
                             GadgetRender,
                             SelectRender        :ADDRESS;
                             GadgetText            :IntuiTextPtr;
                             MutualExclude        :LONGSET;
                             SpecialInfo        :ADDRESS;
                             GadgetID            :INTEGER;
                             UserData            :ADDRESS);

BEGIN
WITH gadget DO
  nextGadget    := NextGadget;
  leftEdge    := X;
  topEdge    := Y;
  width        := Width;
  height    := Height;
  flags        := Flags;
  activation    := Activation;
  gadgetType    := GadgetType;
  gadgetRender    := GadgetRender;
  selectRender    := SelectRender;
  gadgetText    := GadgetText;
  mutualExclude    := MutualExclude;
  specialInfo    := SpecialInfo;
  gadgetID    := GadgetID;
  userData    := UserData
  END
END initGadget;


PROCEDURE initPropInfo    (VAR propInfo            :PropInfo;
                 Flags            :PropInfoFlagSet;
                             VertPot, HorizPot,
                             VertCount, HorizCount    :CARDINAL);

BEGIN
WITH propInfo DO
  flags        := Flags;
  vertPot    := VertPot;
  horizPot    := HorizPot;
  IF VertCount = 0 THEN vertBody    := maxBody
             ELSE vertBody    := maxBody DIV VertCount
    END;
  IF HorizCount = 0 THEN horizBody    := maxBody
             ELSE horizBody    := maxBody DIV HorizCount
    END
  END
END initPropInfo;


PROCEDURE initStringInfo (VAR stringInfo        :StringInfo;
                  Buffer, UndoBuffer    :ADDRESS;
                              BufferPos, MaxChars,
                              DispPos            :INTEGER;
                              AltKeyMap            :KeyMapPtr);


BEGIN
WITH stringInfo DO
  buffer    := Buffer;
  undoBuffer    := UndoBuffer;
  bufferPos    := BufferPos;
  maxChars    := MaxChars;
  dispPos    := DispPos;
  altKeyMap    := AltKeyMap
  END
END initStringInfo;


PROCEDURE refreshOneGadget ( Window            :WindowPtr;
                 Gadget            :GadgetPtr);

VAR    Position    :INTEGER;

BEGIN
Position := RemoveGadget (Window, Gadget);
Position := AddGadget (Window, Gadget, -1);
RefreshGList (Gadget, Window, NIL, 1);
(* Delay (IntuitionWait) *)
END refreshOneGadget;


PROCEDURE refreshAllGadgets (Window            :WindowPtr);

VAR    First, List    :GadgetPtr;
    Position    :INTEGER;

BEGIN
List := Window^.firstGadget;
Position := RemoveGList (Window, List, -1);
WHILE List # NIL DO
  First := List;
  List := First^.nextGadget;
  Position := AddGadget (Window, First, -1);
  RefreshGList (First, Window, NIL, 1)
  END;
(* Delay (IntuitionWait) *)
END refreshAllGadgets;


PROCEDURE refreshSomeGadgets ( Window            :WindowPtr;
                   Gadgets            :LONGSET);

VAR    First, List    :GadgetPtr;
    Position    :INTEGER;

BEGIN
List := Window^.firstGadget;
Position := RemoveGList (Window, List, -1);
WHILE List # NIL DO
  First := List;
  List := First^.nextGadget;
  Position := AddGadget (Window, First, -1);
  IF (First^.gadgetID <= 31) AND (First^.gadgetID IN Gadgets) THEN
    RefreshGList (First, Window, NIL, 1)
    END
  END;
(* Delay (IntuitionWait) *)
END refreshSomeGadgets;


PROCEDURE enableGadget  (    Window            :WindowPtr;
                 Gadget            :GadgetPtr);

VAR    Position    :INTEGER;

BEGIN
IF gadgDisabled IN Gadget^.flags THEN
  Position := RemoveGadget (Window, Gadget);
  EXCL (Gadget^.flags, gadgDisabled);
  Position := AddGadget (Window, Gadget, -1);
  RefreshGList (Gadget, Window, NIL, 1);
(*   Delay (IntuitionWait)*)
  END
END enableGadget;


PROCEDURE enableGadgets    (    Window            :WindowPtr;
                 Gadgets            :LONGSET);

VAR    First, List    :GadgetPtr;
    Position    :INTEGER;

BEGIN
List := Window^.firstGadget;
Position := RemoveGList (Window, List, -1);
WHILE List # NIL DO
  First := List;
  List := First^.nextGadget;
  WITH First^ DO
    IF (gadgDisabled IN flags) AND
       ((gadgetID <= 31) AND (gadgetID IN Gadgets)) THEN
      EXCL (flags, gadgDisabled);
      Position := AddGadget (Window, First, -1);
      RefreshGList (First, Window, NIL, 1)
    ELSE
      Position := AddGadget (Window, First, -1)
      END
    END
  END;
(* Delay (IntuitionWait)*)
END enableGadgets;


PROCEDURE disableGadget (    Window            :WindowPtr;
                 Gadget            :GadgetPtr);

VAR    Position    :INTEGER;

BEGIN
IF NOT (gadgDisabled IN Gadget^.flags) THEN
  Position := RemoveGadget (Window, Gadget);
  INCL (Gadget^.flags, gadgDisabled);
  Position := AddGadget (Window, Gadget, -1);
  RefreshGList (Gadget, Window, NIL, 1);
(*  Delay (IntuitionWait)*)
  END
END disableGadget;


PROCEDURE disableGadgets(    Window            :WindowPtr;
                 Gadgets            :LONGSET);

VAR    First, List    :GadgetPtr;
    Position    :INTEGER;

BEGIN
List := Window^.firstGadget;
Position := RemoveGList (Window, List, -1);
WHILE List # NIL DO
  First := List;
  List := First^.nextGadget;
  WITH First^ DO
    IF NOT (gadgDisabled IN flags) AND
       ((gadgetID <= 31) AND (gadgetID IN Gadgets)) THEN
      INCL (flags, gadgDisabled);
      Position := AddGadget (Window, First, -1);
      RefreshGList (First, Window, NIL, 1)
    ELSE
      Position := AddGadget (Window, First, -1)
      END
    END
  END;
(*Delay (IntuitionWait)*)
END disableGadgets;


PROCEDURE selectGadget  (    Window            :WindowPtr;
                 Gadget            :GadgetPtr);

VAR    Position    :INTEGER;

BEGIN
IF NOT (selected IN Gadget^.flags) THEN
  Position := RemoveGadget (Window, Gadget);
  INCL (Gadget^.flags, selected);
  Position := AddGadget (Window, Gadget, -1);
  RefreshGList (Gadget, Window, NIL, 1);
(*  Delay (IntuitionWait)*)
  END
END selectGadget;


PROCEDURE selectGadgets (    Window            :WindowPtr;
                 Gadgets            :LONGSET);

VAR    First, List    :GadgetPtr;
    Position    :INTEGER;

BEGIN
List := Window^.firstGadget;
Position := RemoveGList (Window, List, -1);
WHILE List # NIL DO
  First := List;
  List := First^.nextGadget;
  WITH First^ DO
    IF NOT (selected IN flags) AND
       ((gadgetID <= 31) AND (gadgetID IN Gadgets)) THEN
      INCL (flags, selected);
      Position := AddGadget (Window, First, -1);
      RefreshGList (First, Window, NIL, 1)
    ELSE
      Position := AddGadget (Window, First, -1);
      END
    END
  END;
(*Delay (IntuitionWait)*)
END selectGadgets;


PROCEDURE deselectGadget (   Window            :WindowPtr;
                 Gadget            :GadgetPtr);

VAR    Position    :INTEGER;

BEGIN
IF selected IN Gadget^.flags THEN
  Position := RemoveGadget (Window, Gadget);
  EXCL (Gadget^.flags, selected);
  Position := AddGadget (Window, Gadget, -1);
  RefreshGList (Gadget, Window, NIL, 1);
(*  Delay (IntuitionWait)*)
  END
END deselectGadget;


PROCEDURE deselectGadgets (  Window            :WindowPtr;
                 Gadgets            :LONGSET);

VAR    First, List    :GadgetPtr;
    Position    :INTEGER;

BEGIN
List := Window^.firstGadget;
Position := RemoveGList (Window, List, -1);
WHILE List # NIL DO
  First := List;
  List := First^.nextGadget;
  WITH First^ DO
    IF (selected IN flags) AND
       ((gadgetID <= 31) AND (gadgetID IN Gadgets)) THEN
      EXCL (flags, selected);
      Position := AddGadget (Window, First, -1);
      RefreshGList (First, Window, NIL, 1)
    ELSE
      Position := AddGadget (Window, First, -1);
      END
    END
  END;
(*Delay (IntuitionWait)*)
END deselectGadgets;


PROCEDURE enableMenus    (    Window            :WindowPtr;
                 Menus            :LONGSET);

VAR    menu    :MenuPtr;
    i    :CARDINAL;

BEGIN
menu := Window^.menuStrip; i := 0;
WHILE menu # NIL DO
  WITH menu^ DO
    IF (i IN Menus) AND NOT (menuEnabled IN flags) THEN
      INCL (flags, menuEnabled)
      END;
    menu := menu^.nextMenu; INC (i)
    END
  END
END enableMenus;


PROCEDURE disableMenus    (    Window            :WindowPtr;
                 Menus            :LONGSET);

VAR    menu    :MenuPtr;
    i    :CARDINAL;

BEGIN
menu := Window^.menuStrip; i := 0;
WHILE menu # NIL DO
  WITH menu^ DO
    IF (i IN Menus) AND (menuEnabled IN flags) THEN
      EXCL (flags, menuEnabled)
      END;
    menu := nextMenu; INC (i)
    END
  END
END disableMenus;


PROCEDURE enableItems    (    Window            :WindowPtr;
                 Menu            :CARDINAL;
                 Items            :LONGSET);

VAR    menu    :MenuPtr;
    item    :MenuItemPtr;
    i    :CARDINAL;

BEGIN
menu := Window^.menuStrip; i := 0;
WHILE (menu # NIL) AND (i < Menu) DO
  menu := menu^.nextMenu; INC (i)
  END;
IF menu = NIL THEN
  RETURN
  END;
item := menu^.firstItem; i := 0;
WHILE item # NIL DO
  WITH item^ DO
    IF (i IN Items) AND NOT (itemEnabled IN flags) THEN
      INCL (flags, itemEnabled)
      END;
    item := nextItem; INC (i)
    END
  END
END enableItems;


PROCEDURE disableItems    (    Window            :WindowPtr;
                 Menu            :CARDINAL;
                 Items            :LONGSET);

VAR    menu    :MenuPtr;
    item    :MenuItemPtr;
    i    :CARDINAL;

BEGIN
menu := Window^.menuStrip; i := 0;
WHILE (menu # NIL) AND (i < Menu) DO
  menu := menu^.nextMenu; INC (i)
  END;
IF menu = NIL THEN
  RETURN
  END;
item := menu^.firstItem; i := 0;
WHILE item # NIL DO
  WITH item^ DO
    IF (i IN Items) AND (itemEnabled IN flags) THEN
      EXCL (flags, itemEnabled)
      END;
    item := nextItem; INC (i)
    END
  END
END disableItems;


PROCEDURE MenuNum    (    Code            :CARDINAL) :CARDINAL;

BEGIN
RETURN (Code MOD 20H)
END MenuNum;


PROCEDURE ItemNum    (    Code            :CARDINAL) :CARDINAL;

BEGIN
RETURN (Code DIV 20H MOD 40H)
END ItemNum;



PROCEDURE RawToVanilla    (    Nachricht            :IntuiMessage;
             VAR VanillaString        :ARRAY OF CHAR);

VAR    actual        :LONGINT;
    Event        :InputEvent;

BEGIN
WITH Event DO
  nextEvent    := NIL;
  class        := rawkey;
  code        := Nachricht.code;
  qualifier    := Nachricht.qualifier;
  eventAddress    := Nachricht.iAddress
  END;
actual := RawKeyConvert (ConsoleDevice,
             ADR (Event),
             ADR (VanillaString),
             HIGH (VanillaString),
             NIL);
IF (actual < 0) OR (actual > HIGH (VanillaString)) THEN
  VanillaString[0] := 0C
ELSE
  VanillaString[actual] := 0C
  END
END RawToVanilla;


PROCEDURE CloseTools;

BEGIN
IF ConsoleDevice # NIL THEN
  CloseDevice (ADR (ConsoleRequest))
  END
END CloseTools;


(* IntuitionTools *)
BEGIN
ConsoleDevice := NIL;
TermProcedure (CloseTools);

OpenDevice (ADR (consoleName), -1, ADR (ConsoleRequest), LONGSET {});
Assert (ConsoleRequest.error = 0, ADR (ConsoleFehler));
ConsoleDevice := ConsoleRequest.device
END IntuitionTools.